home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / clx-resource.l < prev    next >
Lisp/Scheme  |  1989-07-12  |  25KB  |  652 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. (in-package 'xlib :use '(lisp))
  20.  
  21. (export '(resource-database
  22.        resource-database-timestamp
  23.        make-resource-database
  24.        resource-key
  25.        get-resource
  26.        get-search-table
  27.        get-search-resource
  28.        add-resource
  29.        delete-resource 
  30.        map-resource 
  31.        merge-resources
  32.        read-resources
  33.        write-resources
  34.        wm-resources
  35.        set-wm-resources))
  36.  
  37. (defparameter *resource-subclassp* nil)
  38.  
  39.  
  40. ;; The C version of this uses a 64 entry hash table at each entry.
  41. ;; Small hash tables loose in Lisp, so we do linear searches on lists.
  42.  
  43. ;; This code uses resource-database-NAME for resource lookup, and 
  44. ;; resource-database-STRING when reading/writing resources.  This
  45. ;; is to enable us to upcase and intern the string for fast resource
  46. ;; lookup EQ tests while maintaing the original string for 
  47. ;; write-resources [it should be possible to read a upper/lower
  48. ;; case resource file, modify it and write it out correctly]
  49.  
  50. (defstruct (resource-database (:copier nil) (:print-function print-resource)
  51.                   (:constructor make-resource-database-internal)
  52.                   #+explorer (:callable-constructors nil)
  53.                   )
  54.   (name nil :type symbol :read-only t)
  55.   (string "" :type stringable :read-only t)
  56.   (value nil)
  57.   (tight nil :type list) ;; List of resource-database
  58.   (loose nil :type list) ;; List of resource-database
  59.   )
  60.  
  61. ;; The value slot of the top-level resource-database structure is used for a time-stamp.
  62.  
  63. (defun make-resource-database ()
  64.   ;; Make a resource-database with initial timestamp of 0
  65.   (make-resource-database-internal :name :top-level :string "Top-Level" :value 0))
  66.  
  67. (proclaim '(inline resource-database-timestamp))
  68. (defun resource-database-timestamp (database)
  69.   (declare (type resource-database database))
  70.   (resource-database-value database))
  71.  
  72. (defun incf-resource-database-timestamp (database)
  73.   ;; Increment the timestamp
  74.   (declare (type resource-database database))
  75.   (let ((timestamp (resource-database-value database)))
  76.     (setf (resource-database-value database)
  77.       (if (= timestamp most-positive-fixnum)
  78.           most-negative-fixnum
  79.         (1+ timestamp)))))
  80.  
  81. ;; Without this, resources take forever to print...
  82. (defun print-resource (database stream depth)
  83.   (declare (type resource-database database))
  84.   (declare (ignore depth))
  85.   (princ "#<Resource " stream)
  86.   (princ (resource-database-name database))
  87.   (when (resource-database-value database)
  88.     (princ " " stream)
  89.     (prin1 (resource-database-value database)))
  90.   (princ ">"))
  91.  
  92. ;; DEBUG FUNCTION  (not exported)
  93. (defun print-db (entry &optional (level 0) type)
  94.   ;; Debug function to print a resource database
  95.   (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]"
  96.       level
  97.       (resource-database-name entry)
  98.       (EQ type 'loose)
  99.       (resource-database-value entry))
  100.   (when (resource-database-tight entry)
  101.     (dolist (tight (resource-database-tight entry))
  102.       (print-db tight (+ 2 level) 'Tight)))
  103.   (when (resource-database-loose entry)
  104.     (dolist (loose (resource-database-loose entry))
  105.       (print-db loose (+ 2 level) 'Loose))))
  106.  
  107. ;; DEBUG FUNCTION
  108. #+comment
  109. (defun print-search-table (table)
  110.   (terpri)
  111.   (dolist (dbase-list table)
  112.     (format t "~%~s" dbase-list)
  113.     (dolist (db dbase-list)
  114.       (print-db db)
  115.       (dolist (dblist table)
  116.     (unless (eq dblist dbase-list)
  117.       (when (member db dblist)
  118.         (format t "  duplicate at ~s" db))))
  119.       )))
  120.  
  121. (proclaim '(inline resource-key))
  122. (defun resource-key (stringable)
  123.   ;; Ensure STRINGABLE is a keyword.
  124.   (declare (type stringable stringable))
  125.   (if (keywordp stringable)
  126.       (the keyword stringable)
  127.     (resource-key-internal stringable)))
  128.  
  129. (defun resource-key-internal (stringable)
  130.   ;; Ensure STRINGABLE is a keyword.
  131.   (declare (type stringable stringable))
  132.   (if (symbolp stringable)
  133.       (intern (symbol-name stringable) '#,(find-package 'keyword))
  134.     (intern (string-upcase (the string stringable)) '#,(find-package 'keyword))))
  135.  
  136. ;; This is in the inner-loop of the resource search.
  137. ;; Try to be as fast as possible.
  138. (proclaim '(inline stringable-equal))
  139. (defun stringable-equal (a b)
  140.   ;; Compare two stringables.
  141.   ;; Ignore case when comparing to a symbol.
  142.   (declare (type stringable a b))
  143.   (declare-values boolean)
  144.   (macrolet (#+(or ti lmi) ;; Over twice as fast as common-lisp string-equal
  145.          (string-equal (a b)
  146.            `(si:%string-equal ,a 0 ,b 0 nil)))
  147.     (if (symbolp a)
  148.     (if (symbolp b)
  149.         (equal (the string (symbol-name a)) (the string (symbol-name b)))
  150.       (string-equal (the string (symbol-name a)) (the string b)))
  151.       (if (symbolp b)
  152.       (string-equal (the string a) (the string (symbol-name b)))
  153.     #+lispm (equal a b) ;; EQUAL is microcoded on lispm's
  154.     #-lispm (string= (the string a) (the string b))))))
  155.  
  156.  
  157. ;;;-----------------------------------------------------------------------------
  158. ;;; Add/delete resource
  159.  
  160. (defun add-resource (database name-list value)
  161.   ;; name-list is a list of either strings or symbols. If a symbol, 
  162.   ;; case-insensitive comparisons will be used, if a string,
  163.   ;; case-sensitive comparisons will be used.  The symbol '* or
  164.   ;; string "*" are used as wildcards, matching anything or nothing.
  165.   (declare (type resource-database database)
  166.        (type list name-list) ;; (list stringable)
  167.        (type t value))
  168.   (unless value (error "Null resource values are ignored"))
  169.   (incf-resource-database-timestamp database)
  170.   (do* ((list name-list (cdr list))
  171.     (string (car list) (car list))
  172.     (node database)
  173.     (loose-p nil))
  174.        ((endp list)
  175.     (setf (resource-database-value node) value))
  176.     ;; Key is the first name that isn't *
  177.     (if (or (equal string "*") (eq string '*))
  178.     (setq loose-p t)
  179.       ;; find the entry associated with name
  180.       (progn
  181.     (do ((entry (if loose-p
  182.             (resource-database-loose node)
  183.               (resource-database-tight node))
  184.             (cdr entry))
  185.          ;; Terminal names are ALWAYS in the keyword package
  186.          (name (resource-key string)))
  187.         ((endp entry)
  188.          ;; Entry not found - create a new one
  189.          (setq entry (make-resource-database-internal :name name :string string))
  190.          (if loose-p
  191.          (push entry (resource-database-loose node))
  192.            (push entry (resource-database-tight node)))
  193.          (setq node entry))
  194.       (when (stringable-equal string (resource-database-string (car entry)))
  195.         ;; Found entry - use it
  196.         (return (setq node (car entry)))))
  197.     (SETQ loose-p nil)))))
  198.  
  199.  
  200. (defun delete-resource (database name-list)
  201.   (declare (type resource-database database)
  202.        (type list name-list))
  203.   (incf-resource-database-timestamp database)
  204.   (delete-resource-internal database name-list))
  205.  
  206. (defun delete-resource-internal (database name-list)
  207.   (declare (type resource-database database)
  208.        (type list name-list)) ;; (list stringable)
  209.   (do* ((list name-list (cdr list))
  210.     (string (car list) (car list))
  211.     (node database)
  212.     (loose-p nil))
  213.        ((endp list) nil)
  214.     ;; Key is the first name that isn't *
  215.     (if (or (equal string "*") (eq string '*))
  216.     (setq loose-p t)
  217.       ;; find the entry associated with name
  218.       (PROGN 
  219.     (do* ((first-entry (if loose-p
  220.                    (resource-database-loose node)
  221.                  (resource-database-tight node)))
  222.           (entry-list first-entry (cdr entry-list))
  223.           (entry (car entry-list) (car entry-list)))
  224.          ((endp entry-list)
  225.           ;; Entry not found - exit
  226.           (return-from delete-resource-internal nil))
  227.       (when (stringable-equal string (resource-database-string entry))
  228.         (when (cdr list) (delete-resource-internal entry (cdr list)))
  229.         (when (and (null (resource-database-loose entry))
  230.                (null (resource-database-tight entry)))
  231.           (if loose-p
  232.           (setf (resource-database-loose node)
  233.             (delete entry (resource-database-loose node) :test #'eq :count 1))
  234.         (setf (resource-database-tight node)
  235.               (delete entry (resource-database-tight node) :test #'eq :count 1))))
  236.         (return-from delete-resource-internal t)))
  237.     (SETQ loose-p nil)))))
  238.  
  239. ;;;-----------------------------------------------------------------------------
  240. ;;; Get Resource
  241.  
  242. (defun get-resource (database value-name value-class full-name full-class)
  243.   ;; Return the value of the resource in DATABASE whose partial name
  244.   ;; most closely matches (append full-name (list value-name)) and
  245.   ;;                      (append full-class (list value-class)).
  246.   (declare (type resource-database database)
  247.        (type stringable value-name value-class)
  248.        (type list full-name full-class)) ;; (list stringable)
  249.   (declare-values value)
  250.   (let ((names (append full-name (list (resource-key value-name))))
  251.     (classes (append full-class (list (resource-key value-class)))))
  252.     (let* ((result (get-entry (resource-database-tight database) (resource-database-loose database)
  253.                   names classes)))
  254.       (when result
  255.     (resource-database-value result)))))
  256.  
  257. (defun get-entry-lookup (table name names classes)
  258.   (declare (type list table names classes)
  259.        (symbol name))
  260.   (declare (inline get-entry-lookup))
  261.   (dolist (entry table)
  262.     (declare (type resource-database entry))
  263.     (when (stringable-equal name (resource-database-name entry))
  264.       (if (null (cdr names))
  265.       (return entry)
  266.     (let ((result (get-entry (resource-database-tight entry) (resource-database-loose entry)
  267.                  (cdr names) (cdr classes))))
  268.       (declare (type (or null resource-database) result))
  269.       (when result
  270.         (return result)
  271.         ))))))
  272.  
  273. (defun get-entry (tight loose names classes &aux result)
  274.   (declare (type list tight loose names classes))
  275. ;;  (DECLARE (inline get-entry-lookup))
  276.   (declare (inline resource-key))
  277.   (let ((name (car names))
  278.     (class (car classes)))
  279.     (declare (type symbol name class))
  280.     (cond ((and tight
  281.         (get-entry-lookup tight name names classes)))
  282.       ((and loose
  283.         (get-entry-lookup loose name names classes)))
  284.       ((and tight
  285.         (not (equal name class))
  286.         (get-entry-lookup tight class names classes)))
  287.       ((and loose
  288.         (not (equal name class))
  289.         (get-entry-lookup loose class names classes)))
  290.       ((and *resource-subclassp*
  291.         (or loose tight)
  292.         (dolist (class (cluei::class-all-superclasses class))
  293.           (when tight
  294.             (when (setq result (get-entry-lookup tight class names classes))
  295.               (return result)))
  296.           (when loose
  297.             (when (setq result (get-entry-lookup loose class names classes))
  298.               (return result))))))    
  299.       (loose
  300.        (loop
  301.          (pop names) (pop classes)
  302.          (unless (and names classes) (return nil))
  303.          (setq name (car names)
  304.            class (car classes))
  305.          (when (setq result (get-entry-lookup loose name names classes))
  306.            (return result))
  307.          (when (and (not (equal name class))
  308.             (setq result (get-entry-lookup loose class names classes)))
  309.            (return result))
  310.          (when *resource-subclassp*
  311.            (dolist (class (cluei::class-all-superclasses class))
  312.          (when (setq result (get-entry-lookup loose class names classes))
  313.            (return-from get-entry result))))
  314.          )))))
  315.  
  316.  
  317. ;;;-----------------------------------------------------------------------------
  318. ;;; Get-resource with search-table
  319.  
  320. (defun get-search-resource (table name class)
  321.   ;; (get-search-resource (get-search-table database full-name full-class) value-name value-class)
  322.   ;; is equivalent to 
  323.   ;; (get-resource database value-name value-class full-name full-class)
  324.   ;; But since most of the work is done by get-search-table, get-search-resource is MUCH
  325.   ;; faster when getting several resources with the same full-name/full-class
  326.   (declare (type list table)
  327.        (type stringable name class))
  328.   (declare (inline resource-key))
  329.   (let ((name (resource-key name))
  330.     (class (and class (resource-key class))))
  331.     (declare (type stringable name class))
  332.     (block exit
  333.       (dolist (dbase-list table)
  334.     (declare (type list dbase-list))
  335.     (dolist (dbase dbase-list)
  336.       (declare (type resource-database dbase))
  337.       (when (eq name (resource-database-name dbase))
  338.         (return-from exit (resource-database-value dbase))))
  339.     (when (and class (not (eq name class)))
  340.       (dolist (dbase dbase-list)
  341.         (declare (type resource-database dbase))
  342.         (when (eq class (resource-database-name dbase))
  343.           (return-from exit (resource-database-value dbase)))))))))
  344.  
  345. (defun get-search-table (database full-name full-class)
  346.   ;; Return a search table for use with get-search-resource.
  347.   (declare (type resource-database database)
  348.        (type list full-name full-class)) ;; (list stringable)
  349.   (declare-values value)
  350.   (let* ((tight (resource-database-tight database))
  351.      (loose (resource-database-loose database))
  352.      (result (cons nil nil))
  353.      (*result* result))
  354.     (declare (type list tight loose)
  355.          (type cons result)
  356.          (special *result*))
  357.     (when (or tight loose)
  358.       (when full-name
  359.     (get-tables tight loose full-name full-class))
  360.       ;;(vector-push loose table) ;; This catches entries like: (* foreground) :white
  361.       )
  362.     (cdr result)))
  363.  
  364. (proclaim '(inline get-tables-lookup))
  365. (defun get-tables-lookup (dbase name names classes)
  366.   (declare (type list dbase names classes)
  367.        (type symbol name))
  368.   (declare (optimize speed))
  369.   (declare (special *result*))
  370.   (dolist (entry dbase)
  371.     (declare (type resource-database entry))
  372.     (when (stringable-equal name (resource-database-name entry))
  373.       (let ((tight (resource-database-tight entry))
  374.         (loose (resource-database-loose entry)))
  375.     (declare (type list tight loose))
  376.     (when (or tight loose)
  377.       (if (cdr names)
  378.           (get-tables tight loose (cdr names) (cdr classes))
  379.         (when tight
  380.           (let ((result *result*)) ;; Put tight at end of *result*
  381.         (setf (cdr result) (setq *result* (cons tight nil))))))
  382.       (when loose
  383.         (let ((result *result*)) ;; Put loose at end of *result*
  384.           (setf (cdr result) (setq *result* (cons loose nil))))))))))
  385.  
  386. (defun get-tables (tight loose names classes)
  387.   (declare (type list tight loose names classes))
  388.   (declare (inline resource-key)
  389.        (inline get-tables-lookup)
  390.        (optimize speed))
  391.   (let ((name (car names))
  392.     (class (car classes)))
  393.     (declare (type symbol name class))
  394.     (when tight
  395.       (get-tables-lookup tight name names classes))
  396.     (when loose
  397.       (get-tables-lookup loose name names classes))
  398.     (when (and tight (not (equal name class)))
  399.       (get-tables-lookup tight class names classes))
  400.     (when (and loose (not (equal name class)))
  401.       (get-tables-lookup loose class names classes))
  402.     (when *resource-subclassp*
  403.       (dolist (class (cluei::class-all-superclasses class))
  404.     (declare (type symbol class))
  405.     (setq class class)
  406.     (when tight
  407.       (get-tables-lookup tight class names classes))
  408.     (when loose
  409.       (get-tables-lookup loose class names classes))))
  410.     (when loose
  411.       (loop
  412.     (pop names) (pop classes)
  413.     (unless (and names classes) (return nil))
  414.     (setq name (car names)
  415.           class (car classes))
  416.     (get-tables-lookup loose name names classes)
  417.     (unless (equal name class)
  418.       (get-tables-lookup loose class names classes))
  419.     (when *resource-subclassp*
  420.       (dolist (class (cluei::class-all-superclasses class))
  421.         (get-tables-lookup loose class names classes)))
  422.     ))))
  423.  
  424.  
  425. ;;;-----------------------------------------------------------------------------
  426. ;;; Utility functions
  427.  
  428. (defun map-resource (database function &rest args)
  429.   ;; Call FUNCTION on each resource in DATABASE.
  430.   ;; FUNCTION is called with arguments (name-list value . args)
  431.   (declare (type resource-database database)
  432.        (type (function (list t &rest t) t) function))
  433.   (declare-values nil)
  434.   (labels ((map-resource-internal (database function args name)
  435.          (let ((tight (resource-database-tight database))
  436.            (loose (resource-database-loose database)))
  437.            (dolist (resource tight)
  438.          (let ((value (resource-database-value resource))
  439.                (name (append name (list (resource-database-name resource)))))
  440.            (if value
  441.                (apply function name value args)
  442.              (map-resource-internal resource function args name))))
  443.            (dolist (resource loose)
  444.          (let ((value (resource-database-value resource))
  445.                (name (append name (list '* (resource-database-name resource)))))
  446.            (if value
  447.                (apply function name value args)
  448.              (map-resource-internal resource function args name)))))))
  449.     (map-resource-internal database function args nil)))
  450.  
  451. (defun merge-resources (database with-database)
  452.   (declare (type resource-database database with-database))
  453.   (declare-values resource-database)
  454.   (map-resource #'add-resource database with-database)
  455.   with-database)
  456.  
  457. (defun char-memq (key char)
  458.   ;; Used as a test function for POSITION
  459.   (declare (type string-char char))
  460.   (member char key))
  461.  
  462. (eval-when (compile eval) ;; Not needed after compilation
  463. (defmacro resource-with-open-file ((stream pathname &rest options) &body body)
  464.   ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the stream
  465.   (let ((abortp (gensym))
  466.     (streamp (gensym)))
  467.     `(let* ((,abortp t)
  468.         (,streamp (streamp pathname))
  469.         (,stream (if ,streamp pathname (open ,pathname ,@options))))
  470.        (unwind-protect
  471.        (progn
  472.          ,@body
  473.          (setq ,abortp nil))
  474.      (unless ,streamp
  475.        (close stream :abort ,abortp))))))
  476. ) ;; end eval-when
  477.  
  478. (defun read-resources (database pathname &key key test test-not)
  479.   ;; Merges resources from a file in standard X11 format with DATABASE.
  480.   ;; KEY is a function used for converting value-strings, the default is
  481.   ;; identity.  TEST and TEST-NOT are predicates used for filtering
  482.   ;; which resources to include in the database.  They are called with
  483.   ;; the name and results of the KEY function.
  484.   (declare (type resource-database database)
  485.        (type (or pathname string stream) pathname)
  486.        (type (or null (function (string) t)) key)
  487.        (type (or null (function (list t) boolean))
  488.                  test test-not))
  489.   (declare-values resource-database)
  490.   (resource-with-open-file (stream pathname)
  491.     (loop
  492.       (let ((string (read-line stream nil :eof)))
  493.     (declare (type string string))
  494.     (when (eq string :eof) (return database))
  495.     (let* ((end (length string))
  496.            (i (position '(#\tab #\space) string :test-not #'char-memq :end end))
  497.            (term nil))
  498.       (declare (type array-index end)
  499.            (type (or null array-index) i term))
  500.       (when i ;; else blank line
  501.         (case (char string i)
  502.           (#\! nil)  ;; Comment - skip
  503.           (#.(int-char 0) nil) ;; terminator for C strings - skip
  504.           (#\#       ;; Include
  505.            (setq term (position '(#\tab #\space) string :test #'char-memq
  506.                     :start i :end end))
  507.            (if (not (string-equal string "#INCLUDE" :start1 i :end1 term))
  508.            (format t "~%Resource File error. Ignoring: ~a" string)
  509.          (let ((path (merge-pathnames (subseq string (1+ term)) (truename stream))))
  510.            (read-resources database path :key key :test test :test-not test-not))))
  511.           (otherwise
  512.            (multiple-value-bind (name-list value)
  513.            (parse-resource string i end)
  514.          (when
  515.            (cond (test (funcall test name-list value))
  516.              (test-not (not (funcall test-not name-list value)))
  517.              (t t))
  518.            (when key (setq value (funcall key value)))
  519.            (add-resource database name-list value)))))))))))
  520.  
  521. (defun parse-resource (string &optional (start 0) end)
  522.   ;; Parse a resource specfication string into a list of names and a value string
  523.   (declare (type string string)
  524.        (type array-index start)
  525.        (type (or null array-index) end))
  526.   (declare-values name-list value)
  527.   (do ((i start)
  528.        (end (or end (length string)))
  529.        (term)
  530.        (name-list)
  531.        (previous))
  532.       ((>= i end))
  533.     (declare (type array-index end)
  534.          (type (or null array-index) i term))
  535.     (setq term (position '(#\. #\* #\:) string
  536.              :test #'char-memq :start i :end end))
  537.     (case (and term (char string term))
  538.       ;; Name seperator
  539.       (#\. (when (> term i)
  540.          (push (subseq string i term) name-list)))
  541.       ;; Wildcard seperator
  542.       (#\* (when (> term i)
  543.          (push (subseq string i term) name-list))
  544.        (push '* name-list))
  545.       ;; Value seperator
  546.       (#\: (push (subseq string i term) name-list)
  547.        (let* ((start (position '(#\tab #\space) string
  548.                    :test-not #'char-memq
  549.                    :start (1+ term) :end end))
  550.           (value (and (> end start) (subseq string start))))
  551.          (return (values (nreverse name-list) (string-right-trim '(#\tab #\space) value))))))
  552.     (setq previous (char string term))
  553.     (setq i (1+ term))))
  554.  
  555. (defun write-resources (database pathname &key write test test-not)
  556.   ;; Write resources to PATHNAME in the standard X11 format.
  557.   ;; WRITE is a function used for writing values, the default is #'princ
  558.   ;; TEST and TEST-NOT are predicates used for filtering which resources
  559.   ;; to include in the database.  They are called with the name and value.
  560.   (declare (type resource-database database)
  561.        (type (or pathname string stream) pathname)
  562.        (type (or null (function (string stream) t)) write)
  563.        (type (or null (function (list t) boolean))
  564.                  test test-not))
  565.   (resource-with-open-file (stream pathname :direction :output)
  566.     (map-resource
  567.       database
  568.       #'(lambda (name-list value stream write test test-not)
  569.       (when
  570.         (cond (test (funcall test name-list value))
  571.           (test-not (not (funcall test-not name-list value)))
  572.           (t t))
  573.         (let ((previous (car name-list)))
  574.           (princ previous stream)
  575.           (dolist (name (cdr name-list))
  576.         (unless (or (eq name '*) (eq previous '*))
  577.           (write-char #\. stream))
  578.         (setq previous name)
  579.         (princ name stream)))
  580.         (write-string ":    " stream)
  581.         (funcall write value stream)
  582.         (terpri stream)))
  583.       stream (or write #'princ) test test-not))
  584.   database)
  585.  
  586.  
  587. (defun wm-resources (database window &key key test test-not)
  588.   ;; Takes the resources associated with the RESOURCE_MANAGER property
  589.   ;; of WINDOW (if any) and merges them with DATABASE.
  590.   ;; KEY is a function used for converting value-strings, the default is
  591.   ;; identity.  TEST and TEST-NOT are predicates used for filtering
  592.   ;; which resources to include in the database.  They are called with
  593.   ;; the name and results of the KEY function.
  594.   (declare (type resource-database database)
  595.        (type window window)
  596.        (type (or null (function (string) t)) key)
  597.        (type (or null (function (list t) boolean))
  598.                  test test-not))
  599.   (declare-values resource-database)
  600.   (let ((string (get-property window :resource_manager :type :string
  601.                   :result-type 'string :transform #'xlib::card8->char)))
  602.     (when string
  603.       (with-input-from-string (stream string)
  604.     (read-resources database stream :key key :test test :test-not test-not)))))
  605.  
  606. (defun set-wm-resources (database window &key write test test-not)
  607.   ;; Sets the resources associated with the RESOURCE_MANAGER property
  608.   ;; of WINDOW.
  609.   ;; WRITE is a function used for writing values, the default is #'princ
  610.   ;; TEST and TEST-NOT are predicates used for filtering which resources
  611.   ;; to include in the database.  They are called with the name and value.
  612.   (declare (type resource-database database)
  613.        (type window window)
  614.        (type (or null (function (string stream) t)) write)
  615.        (type (or null (function (list t) boolean))
  616.                  test test-not))
  617.   (xlib::set-string-property
  618.     window :resource_manager
  619.     (with-output-to-string (stream)
  620.       (write-resources database stream :write write
  621.                :test test :test-not test-not))))
  622.  
  623.  
  624. ;;;-----------------------------------------------------------------------------
  625. ;;; Tests
  626.  
  627. #|
  628.  
  629. (SETQ db (make-resource-database))
  630.  
  631. (LET (display)
  632.   (UNWIND-PROTECT
  633.       (PROGN (SETQ display (open-display "sun4"))
  634.          (wm-resources db (screen-root (display-default-screen display))))
  635.     (close-display display)))
  636.  
  637. (MAP-RESOURCE db #'(lambda (name value) (FORMAT t "~%Name ~a  Value ~s" name value)))
  638.  
  639. (print-db db)
  640. (print-db clue:*database*)
  641.  
  642. (write-resources db *standard-output*)
  643. (write-resources clue:*database* *standard-output*)
  644.  
  645. (LET (display)
  646.   (UNWIND-PROTECT 
  647.       (PROGN (SETQ display (open-display "sun4"))
  648.          (set-wm-resources clue:*database* (screen-root (display-default-screen display))))
  649.     (display-finish-output display)
  650.     (close-display display)))
  651.  
  652. |#